home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 25 / Cream of the Crop 25.iso / program / fpk65_66.zip / SOURCE / RTL / DOS / ELLIPSE.PPI < prev    next >
Text File  |  1997-01-05  |  3KB  |  100 lines
  1. {FILE: ELLIPSE.PPI }
  2.  
  3.     function CalcEllipse(x,y:Integer;XRadius,YRadius:word):Integer;
  4.      var aq,bq,xq,yq,abq : Longint;
  5.          xp,yp,count     : integer;
  6.      begin
  7.      XRadius:=(XRadius*10000) div XAsp;
  8.      YRadius:=(YRadius*10000) div YAsp;
  9.      aq :=XRadius * XRadius;
  10.      bq :=YRadius * YRadius;
  11.      abq:=aq * bq;
  12.      yp:=YRadius;
  13.      xp:=0;
  14.      count:=0; 
  15.      
  16.       { Berechnung nach : X^2 / A^2 + Y^2 / B^2 = 1               }
  17.       {      umgestellt : X^2 * Y^2 * A^2 * B^2 = A^2*B^2         }
  18.       {      dadurch werden evtuelle Divisionen durch 0 vermieden }
  19.       {      und Integerarithmetik moeglich                       }
  20.  
  21.     repeat              
  22.       PWord(buffermem)[count  ]:=x + xp;
  23.       PWord(buffermem)[count+1]:=y + yp;
  24.       PWord(buffermem)[count+2]:=x - xp;
  25.       PWord(buffermem)[count+3]:=y - yp;
  26.       xq:=xp * xp; yq:=yp * yp;
  27.       if xq * bq + yq * aq >= abq then yp:=yp-1 else xp:=xp+1; 
  28.       Count:=Count+4;
  29.     until yp < 0;
  30.     CalcEllipse:=Count;
  31.   end;
  32.     
  33.   Procedure _Ellipse(Count:Integer);  
  34.     const aq:Integer=0;
  35.     begin
  36.     
  37.     { Das Zeichnen der Ellipse erfolgt in zwei Schleifen, um systematisch }
  38.     { von oben nach unten zu zeichnen und somit ein staendiges Bank-      }
  39.     { umschalten zu verhindern }
  40.     
  41.     while aq <> count do begin
  42.       PutPixel( PWord(buffermem)[aq]  ,PWord(buffermem)[aq+3],aktcolor);
  43.       PutPixel( PWord(buffermem)[aq+2],PWord(buffermem)[aq+3],aktcolor);
  44.       aq:=aq+4;
  45.     end;
  46.     while aq <> 0 do begin
  47.       aq:=aq-4;
  48.       PutPixel( PWord(buffermem)[aq]  ,PWord(buffermem)[aq+1],aktcolor);
  49.       PutPixel( PWord(buffermem)[aq+2],PWord(buffermem)[aq+1],aktcolor);
  50.     end;
  51.   end;
  52.  
  53.   Procedure Fillellipse(x,y:Integer;XRadius,YRadius:word);    
  54.     var Count,index:Word;
  55.         Count8:Word;
  56.         begin
  57.          _graphresult:=grOk;
  58.          if not isgraphmode then
  59.            begin
  60.               _graphresult:=grnoinitgraph;
  61.               exit;
  62.            end;
  63.  
  64.     Count:=CalcEllipse(x,y,XRadius,YRadius);
  65.     if Count=0 then exit;
  66.     Count8:=Count-8;
  67.     index:=0;
  68.     
  69.     while index < count do begin
  70.       while (PWord(buffermem)[index+1]=PWord(buffermem)[index+5]) and
  71.             (index < count8) do Index:=Index+4;
  72.       PatternLine(PWord(buffermem)[index],PWord(buffermem)[index+2],
  73.                   PWord(buffermem)[index+3]); 
  74.       Index:=Index+4;
  75.     end;
  76.     
  77.     while index > 0 do begin   
  78.       index:=index-4;  
  79.       PatternLine(PWord(buffermem)[index],PWord(buffermem)[index+2],
  80.                   PWord(buffermem)[index+1]); 
  81.       while (PWord(buffermem)[index+1]=PWord(buffermem)[index-3]) and
  82.             (index > 4 ) do Index:=Index-4; 
  83.     end;
  84.     
  85.     if (aktColor <> aktFillSettings.Color) or (aktFillSettings.Pattern<>1)
  86.        then _Ellipse(Count);
  87.   end;
  88.     
  89.  
  90.   procedure Circle(x,y:integer;radius:word);
  91.   begin
  92.     _graphresult:=grOk;
  93.     if not isgraphmode then
  94.       begin
  95.         _graphresult:=grnoinitgraph;
  96.         exit;
  97.       end;
  98.     _Ellipse(CalcEllipse(x,y,radius,radius));
  99.   end;  
  100.